home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / faces.el.z / faces.el
Encoding:
Text File  |  1998-05-21  |  69.6 KB  |  1,650 lines
  1. ;;; faces.el --- Lisp interface to the C "face" structure
  2.  
  3. ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
  4. ;; Copyright (C) 1995 Board of Trustees, University of Illinois
  5. ;; Copyright (C) 1995, 1996 Ben Wing
  6.  
  7. ;; Author: Ben Wing <wing@666.com>
  8. ;; Keywords: faces internal
  9. ;;
  10. ;; face implementation #1 (used Lisp vectors and parallel C vectors;
  11. ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@netscape.com>
  12. ;; pre Lucid-Emacs 19.0.
  13. ;;
  14. ;; face implementation #2 (used one face object per frame per face)
  15. ;; authored by Jamie Zawinski for 19.9.
  16. ;;
  17. ;; face implementation #3 (use one face object per face) originally
  18. ;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>,
  19. ;; rewritten by Ben Wing with the advent of specifiers.
  20.  
  21. ;; This file is part of XEmacs.
  22.  
  23. ;; XEmacs is free software; you can redistribute it and/or modify it
  24. ;; under the terms of the GNU General Public License as published by
  25. ;; the Free Software Foundation; either version 2, or (at your option)
  26. ;; any later version.
  27.  
  28. ;; XEmacs is distributed in the hope that it will be useful, but
  29. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  30. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  31. ;; General Public License for more details.
  32.  
  33. ;; You should have received a copy of the GNU General Public License
  34. ;; along with XEmacs; see the file COPYING.  If not, write to the
  35. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  36. ;; Boston, MA 02111-1307, USA.
  37.  
  38. ;;; Synched up with: Not synched with FSF.  Almost completely divergent.
  39. ;;; Some stuff in FSF's faces.el is in our x-faces.el.
  40.  
  41. (defun read-face-name (prompt)
  42.   (let (face)
  43.     (while (= (length face) 0) ; nil or ""
  44.       (setq face (completing-read prompt
  45.                   (mapcar (lambda (x) (list (symbol-name x)))
  46.                       (face-list))
  47.                   nil t)))
  48.     (intern face)))
  49.  
  50. (defun face-interactive (what &optional bool)
  51.   (let* ((fn (intern (concat "face-" what "-instance")))
  52.      (face (read-face-name (format "Set %s of face: " what)))
  53.      (default (if (fboundp fn)
  54.               ;; #### we should distinguish here between
  55.               ;; explicitly setting the value to be the
  56.               ;; same as the default face's value, and
  57.               ;; not setting a value at all.
  58.               (funcall fn face)))
  59.      (value (if bool
  60.             (y-or-n-p (format "Should face %s be %s? "
  61.                       (symbol-name face) bool))
  62.           (read-string (format "Set %s of face %s to: "
  63.                        what (symbol-name face))
  64.            (cond ((font-instance-p default)
  65.               (font-instance-name default))
  66.              ((color-instance-p default)
  67.               (color-instance-name default))
  68.              ((image-instance-p default)
  69.               (image-instance-file-name default))
  70.              (t default))))))
  71.     (list face (if (equal value "") nil value))))
  72.  
  73. (defconst built-in-face-specifiers
  74.   (built-in-face-specifiers)
  75.   "A list of the built-in face properties that are specifiers.")
  76.  
  77. (defun face-property (face property &optional locale tag-set exact-p)
  78.   "Return FACE's value of the given PROPERTY.
  79.  
  80. If LOCALE is omitted, the FACE's actual value for PROPERTY will be
  81.   returned.  For built-in properties, this will be a specifier object
  82.   of a type appropriate to the property (e.g. a font or color
  83.   specifier).  For other properties, this could be anything.
  84.  
  85. If LOCALE is supplied, then instead of returning the actual value,
  86.   the specification(s) for the given locale or locale type will
  87.   be returned.  This will only work if the actual value of
  88.   PROPERTY is a specifier (this will always be the case for built-in
  89.   properties, but not or not may apply to user-defined properties).
  90.   If the actual value of PROPERTY is not a specifier, this value
  91.   will simply be returned regardless of LOCALE.
  92.  
  93. The return value will be a list of instantiators (e.g. strings
  94.   specifying a font or color name), or a list of specifications, each
  95.   of which is a cons of a locale and a list of instantiators.
  96.   Specifically, if LOCALE is a particular locale (a buffer, window,
  97.   frame, device, or 'global), a list of instantiators for that locale
  98.   will be returned.  Otherwise, if LOCALE is a locale type (one of
  99.   the symbols 'buffer, 'window, 'frame, or 'device), the specifications
  100.   for all locales of that type will be returned.  Finally, if LOCALE is
  101.   'all, the specifications for all locales of all types will be returned.
  102.  
  103. The specifications in a specifier determine what the value of
  104.   PROPERTY will be in a particular \"domain\" or set of circumstances,
  105.   which is typically a particular Emacs window along with the buffer
  106.   it contains and the frame and device it lies within.  The value
  107.   is derived from the instantiator associated with the most specific
  108.   locale (in the order buffer, window, frame, device, and 'global)
  109.   that matches the domain in question.  In other words, given a domain
  110.   (i.e. an Emacs window, usually), the specifier for PROPERTY will first
  111.   be searched for a specification whose locale is the buffer contained
  112.   within that window; then for a specification whose locale is the window
  113.   itself; then for a specification whose locale is the frame that the
  114.   window is contained within; etc.  The first instantiator that is
  115.   valid for the domain (usually this means that the instantiator is
  116.   recognized by the device [i.e. the X server or TTY device] that the
  117.   domain is on.  The function `face-property-instance' actually does
  118.   all this, and is used to determine how to display the face.
  119.  
  120. See `set-face-property' for the built-in property-names."
  121.  
  122.   (setq face (get-face face))
  123.   (let ((value (get face property)))
  124.     (if (and locale
  125.          (or (memq property built-in-face-specifiers)
  126.          (specifierp value)))
  127.     (setq value (specifier-specs value locale tag-set exact-p)))
  128.     value))
  129.  
  130. (defun convert-face-property-into-specifier (face property)
  131.   "Convert PROPERTY on FACE into a specifier, if it's not already."
  132.   (setq face (get-face face))
  133.   (let ((specifier (get face property)))
  134.     ;; if a user-property does not have a specifier but a
  135.     ;; locale was specified, put a specifier there.  
  136.     ;; If there was already a value there, convert it to a
  137.     ;; specifier with the value as its 'global instantiator.
  138.     (unless (specifierp specifier)
  139.       (let ((new-specifier (make-specifier 'generic)))
  140.     (if (or (not (null specifier))
  141.         ;; make sure the nil returned from `get' wasn't
  142.         ;; actually the value of the property
  143.         (null (get face property t)))
  144.         (add-spec-to-specifier new-specifier specifier))
  145.     (setq specifier new-specifier)
  146.     (put face property specifier)))))
  147.  
  148. (defun face-property-instance (face property
  149.                     &optional domain default no-fallback)
  150.   "Return the instance of FACE's PROPERTY in the specified DOMAIN.
  151.  
  152. Under most circumstances, DOMAIN will be a particular window,
  153.   and the returned instance describes how the specified property
  154.   actually is displayed for that window and the particular buffer
  155.   in it.  Note that this may not be the same as how the property
  156.   appears when the buffer is displayed in a different window or
  157.   frame, or how the property appears in the same window if you
  158.   switch to another buffer in that window; and in those cases,
  159.   the returned instance would be different.
  160.  
  161. The returned instance will typically be a color-instance,
  162.   font-instance, or pixmap-instance object, and you can query
  163.   it using the appropriate object-specific functions.  For example,
  164.   you could use `color-instance-rgb-components' to find out the
  165.   RGB (red, green, and blue) components of how the 'background
  166.   property of the 'highlight face is displayed in a particular
  167.   window.  The results might be different from the results
  168.   you would get for another window (perhaps the user
  169.   specified a different color for the frame that window is on;
  170.   or perhaps the same color was specified but the window is
  171.   on a different X server, and that X server has different RGB
  172.   values for the color from this one).
  173.  
  174. DOMAIN defaults to the selected window if omitted.
  175.  
  176. DOMAIN can be a frame or device, instead of a window.  The value
  177.   returned for a such a domain is used in special circumstances
  178.   when a more specific domain does not apply; for example, a frame
  179.   value might be used for coloring a toolbar, which is conceptually
  180.   attached to a frame rather than a particular window.  The value
  181.   is also useful in determining what the value would be for a
  182.   particular window within the frame or device, if it is not
  183.   overridden by a more specific specification.
  184.  
  185. If PROPERTY does not name a built-in property, its value will
  186.   simply be returned unless it is a specifier object, in which case
  187.   it will be instanced using `specifier-instance'.
  188.  
  189. Optional arguments DEFAULT and NO-FALLBACK are the same as in
  190.   `specifier-instance'."
  191.  
  192.   (setq face (get-face face))
  193.   (let ((value (get face property)))
  194.     (if (specifierp value)
  195.     (setq value (specifier-instance value domain default no-fallback)))
  196.     value))
  197.  
  198. (defun face-property-matching-instance (face property matchspec
  199.                          &optional domain default
  200.                          no-fallback)
  201.   "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN.
  202. Currently the only useful value for MATCHSPEC is a charset, when used
  203. in conjunction with the face's font; this allows you to retrieve a
  204. font that can be used to display a particular charset, rather than just
  205. any font.
  206.  
  207. Other than MATCHSPEC, this function is identical to `face-property-instance'.
  208. See also `specifier-matching-instance' for a fuller description of the
  209. matching process."
  210.  
  211.   (setq face (get-face face))
  212.   (let ((value (get face property)))
  213.     (if (specifierp value)
  214.     (setq value (specifier-matching-instance value matchspec domain
  215.                          default no-fallback)))
  216.     value))
  217.  
  218. (defun set-face-property (face property value &optional locale tag-set
  219.                    how-to-add)
  220.   "Change a property of a FACE.
  221.  
  222. NOTE: If you want to remove a property from a face, use `remove-face-property'
  223.   rather than attempting to set a value of nil for the property.
  224.  
  225. For built-in properties, the actual value of the property is a
  226.   specifier and you cannot change this; but you can change the
  227.   specifications within the specifier, and that is what this function
  228.   will do.  For user-defined properties, you can use this function
  229.   to either change the actual value of the property or, if this value
  230.   is a specifier, change the specifications within it.
  231.  
  232. If PROPERTY is a built-in property, the specifications to be added to
  233.   this property can be supplied in many different ways:
  234.  
  235.   -- If VALUE is a simple instantiator (e.g. a string naming a font or
  236.      color) or a list of instantiators, then the instantiator(s) will
  237.      be added as a specification of the property for the given LOCALE
  238.      (which defaults to 'global if omitted).
  239.   -- If VALUE is a list of specifications (each of which is a cons of
  240.      a locale and a list of instantiators), then LOCALE must be nil
  241.      (it does not make sense to explicitly specify a locale in this
  242.      case), and specifications will be added as given.
  243.   -- If VALUE is a specifier (as would be returned by `face-property'
  244.      if no LOCALE argument is given), then some or all of the
  245.      specifications in the specifier will be added to the property.
  246.      In this case, the function is really equivalent to
  247.      `copy-specifier' and LOCALE has the same semantics (if it is
  248.      a particular locale, the specification for the locale will be
  249.      copied; if a locale type, specifications for all locales of
  250.      that type will be copied; if nil or 'all, then all
  251.      specifications will be copied).
  252.  
  253. HOW-TO-ADD should be either nil or one of the symbols 'prepend,
  254.   'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale,
  255.   'remove-locale-type, or 'remove-all.  See `copy-specifier' and
  256.   `add-spec-to-specifier' for a description of what each of
  257.   these means.  Most of the time, you do not need to worry about
  258.   this argument; the default behavior usually is fine.
  259.  
  260. In general, it is OK to pass an instance object (e.g. as returned
  261.   by `face-property-instance') as an instantiator in place of
  262.   an actual instantiator.  In such a case, the instantiator used
  263.   to create that instance object will be used (for example, if
  264.   you set a font-instance object as the value of the 'font
  265.   property, then the font name used to create that object will
  266.   be used instead).  If some cases, however, doing this
  267.   conversion does not make sense, and this will be noted in
  268.   the documentation for particular types of instance objects.
  269.  
  270. If PROPERTY is not a built-in property, then this function will
  271.   simply set its value if LOCALE is nil.  However, if LOCALE is
  272.   given, then this function will attempt to add VALUE as the
  273.   instantiator for the given LOCALE, using `add-spec-to-specifier'.
  274.   If the value of the property is not a specifier, it will
  275.   automatically be converted into a 'generic specifier.
  276.  
  277.  
  278. The following symbols have predefined meanings:
  279.  
  280.  foreground         The foreground color of the face.
  281.                     For valid instantiators, see `color-specifier-p'.
  282.             
  283.  background         The background color of the face.
  284.                     For valid instantiators, see `color-specifier-p'.
  285.             
  286.  font               The font used to display text covered by this face.
  287.                     For valid instantiators, see `font-specifier-p'.
  288.             
  289.  display-table      The display table of the face.
  290.                     This should be a vector of 256 elements.
  291.             
  292.  background-pixmap  The pixmap displayed in the background of the face.
  293.                     Only used by faces on X devices.
  294.                     For valid instantiators, see `image-specifier-p'.
  295.  
  296.  underline          Underline all text covered by this face.
  297.                     For valid instantiators, see `face-boolean-specifier-p'.
  298.  
  299.  strikethru         Draw a line through all text covered by this face.
  300.                     For valid instantiators, see `face-boolean-specifier-p'.
  301.  
  302.  highlight          Highlight all text covered by this face.
  303.                     Only used by faces on TTY devices.
  304.                     For valid instantiators, see `face-boolean-specifier-p'.
  305.             
  306.  dim                Dim all text covered by this face.
  307.                     Only used by faces on TTY devices.
  308.                     For valid instantiators, see `face-boolean-specifier-p'.
  309.             
  310.  blinking           Blink all text covered by this face.
  311.                     Only used by faces on TTY devices.
  312.                     For valid instantiators, see `face-boolean-specifier-p'.
  313.             
  314.  reverse            Reverse the foreground and background colors.
  315.                     Only used by faces on TTY devices.
  316.                     For valid instantiators, see `face-boolean-specifier-p'.
  317.             
  318.  doc-string         Description of what the face's normal use is.
  319.                     NOTE: This is not a specifier, unlike all
  320.                     the other built-in properties, and cannot
  321.                     contain locale-specific values."
  322.  
  323.   (setq face (get-face face))
  324.   (if (memq property built-in-face-specifiers)
  325.       (set-specifier (get face property) value locale tag-set how-to-add)
  326.  
  327.     ;; This section adds user defined properties.
  328.     (if (not locale)
  329.     (put face property value)
  330.       (convert-face-property-into-specifier face property)
  331.       (add-spec-to-specifier (get face property) value locale tag-set
  332.                  how-to-add)))
  333.   value)
  334.  
  335. (defun remove-face-property (face property &optional locale tag-set exact-p)
  336.   "Remove a property from a face.
  337. For built-in properties, this is analogous to `remove-specifier'.
  338. See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P
  339. arguments."
  340.   (or locale (setq locale 'all))
  341.   (if (memq property built-in-face-specifiers)
  342.       (remove-specifier (face-property face property) locale tag-set exact-p)
  343.     (if (eq locale 'all)
  344.     (remprop (get-face face) property)
  345.       (convert-face-property-into-specifier face property)
  346.       (remove-specifier (face-property face property) locale tag-set
  347.             exact-p))))
  348.  
  349. (defun reset-face (face &optional locale tag-set exact-p)
  350.   "Clear all existing built-in specifications from FACE.
  351. This makes FACE inherit all its display properties from 'default.
  352. WARNING: Be absolutely sure you want to do this!!!  It is a dangerous
  353. operation and is not undoable.
  354.  
  355. The arguments LOCALE, TAG-SET and EXACT-P are the same as for
  356. `remove-specifier'."
  357.   (mapc (lambda (x)
  358.       (remove-specifier (face-property face x) locale tag-set exact-p))
  359.     built-in-face-specifiers)
  360.   nil)
  361.  
  362. (defun set-face-parent (face parent &optional locale tag-set how-to-add)
  363.   "Set the parent of FACE to PARENT, for all properties.
  364. This makes all properties of FACE inherit from PARENT."
  365.   (setq parent (get-face parent))
  366.   (mapcar (lambda (x)
  367.         (set-face-property face x (vector parent) locale tag-set
  368.                    how-to-add))
  369.       (delq 'display-table
  370.         (delq 'background-pixmap
  371.               (copy-sequence built-in-face-specifiers))))
  372.   (set-face-background-pixmap face (vector 'inherit ':face parent)
  373.                   locale tag-set how-to-add)
  374.   nil)
  375.  
  376. (defun face-doc-string (face)
  377.   "Return the documentation string for FACE."
  378.   (face-property face 'doc-string))
  379.  
  380. (defun set-face-doc-string (face doc-string)
  381.   "Change the documentation string of FACE to DOC-STRING."
  382.   (interactive (face-interactive "doc-string"))
  383.   (set-face-property face 'doc-string doc-string))
  384.  
  385. (defun face-font-name (face &optional domain charset)
  386.   "Return the font name of the given face, or nil if it is unspecified.
  387. DOMAIN is as in `face-font-instance'."
  388.   (let ((f (face-font-instance face domain charset)))
  389.     (and f (font-instance-name f))))
  390.  
  391. (defun face-font (face &optional locale tag-set exact-p)
  392.   "Return the font of the given face, or nil if it is unspecified.
  393.  
  394. FACE may be either a face object or a symbol representing a face.
  395.  
  396. LOCALE may be a locale (the instantiators for that particular locale
  397.   will be returned), a locale type (the specifications for all locales
  398.   of that type will be returned), 'all (all specifications will be
  399.   returned), or nil (the actual specifier object will be returned).
  400.  
  401. See `face-property' for more information."
  402.   (face-property face 'font locale tag-set exact-p))
  403.  
  404. (defun face-font-instance (face &optional domain charset)
  405.   "Return the instance of the given face's font in the given domain.
  406.  
  407. FACE may be either a face object or a symbol representing a face.
  408.  
  409. Normally DOMAIN will be a window or nil (meaning the selected window),
  410.   and an instance object describing how the font appears in that
  411.   particular window and buffer will be returned.
  412.  
  413. See `face-property-instance' for more information."
  414.   (if charset
  415.       (face-property-matching-instance face 'font charset domain)
  416.     (face-property-instance face 'font domain)))
  417.  
  418. (defun set-face-font (face font &optional locale tag-set how-to-add)
  419.   "Change the font of the given face.
  420.  
  421. FACE may be either a face object or a symbol representing a face.
  422.  
  423. FONT should be an instantiator (see `font-specifier-p'), a list of
  424.   instantiators, an alist of specifications (each mapping a
  425.   locale to an instantiator list), or a font specifier object.
  426.  
  427. If FONT is an alist, LOCALE must be omitted.  If FONT is a
  428.   specifier object, LOCALE can be a locale, a locale type, 'all,
  429.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  430.   specifies the locale under which the specified instantiator(s)
  431.   will be added, and defaults to 'global.
  432.  
  433. See `set-face-property' for more information."
  434.   (interactive (face-interactive "font"))
  435.   (set-face-property face 'font font locale tag-set how-to-add))
  436.  
  437. (defun face-foreground (face &optional locale tag-set exact-p)
  438.   "Return the foreground of the given face, or nil if it is unspecified.
  439.  
  440. FACE may be either a face object or a symbol representing a face.
  441.  
  442. LOCALE may be a locale (the instantiators for that particular locale
  443.   will be returned), a locale type (the specifications for all locales
  444.   of that type will be returned), 'all (all specifications will be
  445.   returned), or nil (the actual specifier object will be returned).
  446.  
  447. See `face-property' for more information."
  448.   (face-property face 'foreground locale tag-set exact-p))
  449.  
  450. (defun face-foreground-instance (face &optional domain default no-fallback)
  451.   "Return the instance of the given face's foreground in the given domain.
  452.  
  453. FACE may be either a face object or a symbol representing a face.
  454.  
  455. Normally DOMAIN will be a window or nil (meaning the selected window),
  456.   and an instance object describing how the foreground appears in that
  457.   particular window and buffer will be returned.
  458.  
  459. See `face-property-instance' for more information."
  460.   (face-property-instance face 'foreground domain default no-fallback))
  461.  
  462. (defun face-foreground-name (face &optional domain default no-fallback)
  463.   "Return the name of the given face's foreground color in the given domain.
  464.  
  465. FACE may be either a face object or a symbol representing a face.
  466.  
  467. Normally DOMAIN will be a window or nil (meaning the selected window),
  468.   and an instance object describing how the background appears in that
  469.   particular window and buffer will be returned.
  470.  
  471. See `face-property-instance' for more information."
  472.   (color-instance-name (face-foreground-instance
  473.             face domain default no-fallback)))
  474.  
  475. (defun set-face-foreground (face color &optional locale tag-set how-to-add)
  476.   "Change the foreground of the given face.
  477.  
  478. FACE may be either a face object or a symbol representing a face.
  479.  
  480. COLOR should be an instantiator (see `color-specifier-p'), a list of
  481.   instantiators, an alist of specifications (each mapping a locale to
  482.   an instantiator list), or a color specifier object.
  483.  
  484. If COLOR is an alist, LOCALE must be omitted.  If COLOR is a
  485.   specifier object, LOCALE can be a locale, a locale type, 'all,
  486.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  487.   specifies the locale under which the specified instantiator(s)
  488.   will be added, and defaults to 'global.
  489.  
  490. See `set-face-property' for more information."
  491.   (interactive (face-interactive "foreground"))
  492.   (set-face-property face 'foreground color locale tag-set how-to-add))
  493.  
  494. (defun face-background (face &optional locale tag-set exact-p)
  495.   "Return the background of the given face, or nil if it is unspecified.
  496.  
  497. FACE may be either a face object or a symbol representing a face.
  498.  
  499. LOCALE may be a locale (the instantiators for that particular locale
  500.   will be returned), a locale type (the specifications for all locales
  501.   of that type will be returned), 'all (all specifications will be
  502.   returned), or nil (the actual specifier object will be returned).
  503.  
  504. See `face-property' for more information."
  505.   (face-property face 'background locale tag-set exact-p))
  506.  
  507. (defun face-background-instance (face &optional domain default no-fallback)
  508.   "Return the instance of the given face's background in the given domain.
  509.  
  510. FACE may be either a face object or a symbol representing a face.
  511.  
  512. Normally DOMAIN will be a window or nil (meaning the selected window),
  513.   and an instance object describing how the background appears in that
  514.   particular window and buffer will be returned.
  515.  
  516. See `face-property-instance' for more information."
  517.   (face-property-instance face 'background domain default no-fallback))
  518.  
  519. (defun face-background-name (face &optional domain default no-fallback)
  520.   "Return the name of the given face's background color in the given domain.
  521.  
  522. FACE may be either a face object or a symbol representing a face.
  523.  
  524. Normally DOMAIN will be a window or nil (meaning the selected window),
  525.   and an instance object describing how the background appears in that
  526.   particular window and buffer will be returned.
  527.  
  528. See `face-property-instance' for more information."
  529.   (color-instance-name (face-background-instance
  530.             face domain default no-fallback)))
  531.  
  532. (defun set-face-background (face color &optional locale tag-set how-to-add)
  533.   "Change the background of the given face.
  534.  
  535. FACE may be either a face object or a symbol representing a face.
  536.  
  537. COLOR should be an instantiator (see `color-specifier-p'), a list of
  538.   instantiators, an alist of specifications (each mapping a locale to
  539.   an instantiator list), or a color specifier object.
  540.  
  541. If COLOR is an alist, LOCALE must be omitted.  If COLOR is a
  542.   specifier object, LOCALE can be a locale, a locale type, 'all,
  543.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  544.   specifies the locale under which the specified instantiator(s)
  545.   will be added, and defaults to 'global.
  546.  
  547. See `set-face-property' for more information."
  548.   (interactive (face-interactive "background"))
  549.   (set-face-property face 'background color locale tag-set how-to-add))
  550.  
  551. (defun face-background-pixmap (face &optional locale tag-set exact-p)
  552.   "Return the background pixmap of the given face, or nil if it is unspecified.
  553. This property is only used on X devices.
  554.  
  555. FACE may be either a face object or a symbol representing a face.
  556.  
  557. LOCALE may be a locale (the instantiators for that particular locale
  558.   will be returned), a locale type (the specifications for all locales
  559.   of that type will be returned), 'all (all specifications will be
  560.   returned), or nil (the actual specifier object will be returned).
  561.  
  562. See `face-property' for more information."
  563.   (face-property face 'background-pixmap locale tag-set exact-p))
  564.  
  565. (defun face-background-pixmap-instance (face &optional domain default
  566.                          no-fallback)
  567.   "Return the instance of the given face's background pixmap in the given domain.
  568.  
  569. FACE may be either a face object or a symbol representing a face.
  570.  
  571. Normally DOMAIN will be a window or nil (meaning the selected window),
  572.   and an instance object describing how the background appears in that
  573.   particular window and buffer will be returned.
  574.  
  575. See `face-property-instance' for more information."
  576.   (face-property-instance face 'background-pixmap domain default no-fallback))
  577.  
  578. (defun set-face-background-pixmap (face pixmap &optional locale tag-set
  579.                     how-to-add)
  580.   "Change the background pixmap of the given face.
  581. This property is only used on X devices.
  582.  
  583. FACE may be either a face object or a symbol representing a face.
  584.  
  585. PIXMAP should be an instantiator (see `image-specifier-p'), a list
  586.   of instantiators, an alist of specifications (each mapping a locale
  587.   to an instantiator list), or an image specifier object.
  588.  
  589. If PIXMAP is an alist, LOCALE must be omitted.  If PIXMAP is a
  590.   specifier object, LOCALE can be a locale, a locale type, 'all,
  591.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  592.   specifies the locale under which the specified instantiator(s)
  593.   will be added, and defaults to 'global.
  594.  
  595. See `set-face-property' for more information."
  596.   (interactive (face-interactive "background-pixmap"))
  597.   (set-face-property face 'background-pixmap pixmap locale tag-set how-to-add))
  598.  
  599. (defun face-display-table (face &optional locale tag-set exact-p)
  600.   "Return the display table of the given face.
  601.  
  602. A vector (as returned by `make-display-table') will be returned.
  603.  
  604. LOCALE may be a locale (the instantiators for that particular locale
  605.   will be returned), a locale type (the specifications for all locales
  606.   of that type will be returned), 'all (all specifications will be
  607.   returned), or nil (the actual specifier object will be returned).
  608.  
  609. See `face-property' for more information."
  610.   (face-property face 'display-table locale tag-set exact-p))
  611.  
  612. (defun face-display-table-instance (face &optional domain default no-fallback)
  613.   "Return the instance of FACE's display table in DOMAIN.
  614. A vector (as returned by `make-display-table') will be returned.
  615.  
  616. See `face-property-instance' for the semantics of the DOMAIN argument."
  617.   (face-property-instance face 'display-table domain default no-fallback))
  618.  
  619. (defun set-face-display-table (face display-table &optional locale tag-set
  620.                     how-to-add)
  621.   "Change the display table of the given face.
  622. DISPLAY-TABLE should be a vector as returned by `make-display-table'.
  623.  
  624. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
  625.   HOW-TO-ADD arguments."
  626.   (interactive (face-interactive "display-table"))
  627.   (set-face-property face 'display-table display-table locale tag-set
  628.              how-to-add))
  629.  
  630. ;; The following accessors and mutators are, IMHO, good
  631. ;; implementation.  Cf. with `make-face-bold'.
  632.  
  633. (defun face-underline-p (face &optional domain default no-fallback)
  634.   "Return whether the given face is underlined.
  635. See `face-property-instance' for the semantics of the DOMAIN argument."
  636.   (face-property-instance face 'underline domain default no-fallback))
  637.  
  638. (defun set-face-underline-p (face underline-p &optional locale tag-set
  639.                   how-to-add)
  640.   "Change whether the given face is underlined.
  641. UNDERLINE-P is normally a face-boolean instantiator; see
  642.  `face-boolean-specifier-p'.
  643. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
  644.  HOW-TO-ADD arguments."
  645.   (interactive (face-interactive "underline-p" "underlined"))
  646.   (set-face-property face 'underline underline-p locale tag-set how-to-add))
  647.  
  648. (defun face-strikethru-p (face &optional domain default no-fallback)
  649.   "Return whether the given face is strikethru-d (i.e. struck through).
  650. See `face-property-instance' for the semantics of the DOMAIN argument."
  651.   (face-property-instance face 'strikethru domain default no-fallback))
  652.  
  653. (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set
  654.                   how-to-add)
  655.   "Change whether the given face is strikethru-d (i.e. struck through).
  656. STRIKETHRU-P is normally a face-boolean instantiator; see
  657.  `face-boolean-specifier-p'.
  658. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
  659.  HOW-TO-ADD arguments."
  660.   (interactive (face-interactive "strikethru-p" "strikethru-d"))
  661.   (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add))
  662.  
  663. (defun face-highlight-p (face &optional domain default no-fallback)
  664.   "Return whether the given face is highlighted (TTY domains only).
  665. See `face-property-instance' for the semantics of the DOMAIN argument."
  666.   (face-property-instance face 'highlight domain default no-fallback))
  667.  
  668. (defun set-face-highlight-p (face highlight-p &optional locale tag-set
  669.                   how-to-add)
  670.   "Change whether the given face is highlighted (TTY locales only).
  671. HIGHLIGHT-P is normally a face-boolean instantiator; see
  672.  `face-boolean-specifier-p'.
  673. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
  674.  HOW-TO-ADD arguments."
  675.   (interactive (face-interactive "highlight-p" "highlighted"))
  676.   (set-face-property face 'highlight highlight-p locale tag-set how-to-add))
  677.  
  678. (defun face-dim-p (face &optional domain default no-fallback)
  679.   "Return whether the given face is dimmed (TTY domains only).
  680. See `face-property-instance' for the semantics of the DOMAIN argument."
  681.   (face-property-instance face 'dim domain default no-fallback))
  682.  
  683. (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add)
  684.   "Change whether the given face is dimmed (TTY locales only).
  685. DIM-P is normally a face-boolean instantiator; see
  686.  `face-boolean-specifier-p'.
  687. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
  688.  HOW-TO-ADD arguments."
  689.   (interactive (face-interactive "dim-p" "dimmed"))
  690.   (set-face-property face 'dim dim-p locale tag-set how-to-add))
  691.  
  692. (defun face-blinking-p (face &optional domain default no-fallback)
  693.   "Return whether the given face is blinking (TTY domains only).
  694. See `face-property-instance' for the semantics of the DOMAIN argument."
  695.   (face-property-instance face 'blinking domain default no-fallback))
  696.  
  697. (defun set-face-blinking-p (face blinking-p &optional locale tag-set
  698.                  how-to-add)
  699.   "Change whether the given face is blinking (TTY locales only).
  700. BLINKING-P is normally a face-boolean instantiator; see
  701.  `face-boolean-specifier-p'.
  702. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
  703.  HOW-TO-ADD arguments."
  704.   (interactive (face-interactive "blinking-p" "blinking"))
  705.   (set-face-property face 'blinking blinking-p locale tag-set how-to-add))
  706.  
  707. (defun face-reverse-p (face &optional domain default no-fallback)
  708.   "Return whether the given face is reversed (TTY domains only).
  709. See `face-property-instance' for the semantics of the DOMAIN argument."
  710.   (face-property-instance face 'reverse domain default no-fallback))
  711.  
  712. (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add)
  713.   "Change whether the given face is reversed (TTY locales only).
  714. REVERSE-P is normally a face-boolean instantiator; see
  715.  `face-boolean-specifier-p'.
  716. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
  717.  HOW-TO-ADD arguments."
  718.   (interactive (face-interactive "reverse-p" "reversed"))
  719.   (set-face-property face 'reverse reverse-p locale tag-set how-to-add))
  720.  
  721.  
  722. (defun face-property-equal (face1 face2 prop domain)
  723.   (equal (face-property-instance face1 prop domain)
  724.      (face-property-instance face2 prop domain)))
  725.  
  726. (defun face-equal-loop (props face1 face2 domain)
  727.   (while (and props
  728.           (face-property-equal face1 face2 (car props) domain))
  729.     (setq props (cdr props)))
  730.   (null props))
  731.  
  732. (defun face-equal (face1 face2 &optional domain)
  733.   "True if the given faces will display in the same way.
  734. See `face-property-instance' for the semantics of the DOMAIN argument."
  735.   (if (null domain) (setq domain (selected-window)))
  736.   (if (not (valid-specifier-domain-p domain))
  737.       (error "Invalid specifier domain"))
  738.   (let ((device (dfw-device domain))
  739.     (common-props '(foreground background font display-table underline))
  740.     (x-props '(background-pixmap strikethru))
  741.     (tty-props '(highlight dim blinking reverse)))
  742.  
  743.     ;; First check the properties which are used in common between the
  744.     ;; x and tty devices.  Then, check those properties specific to
  745.     ;; the particular device type.
  746.     (and (face-equal-loop common-props face1 face2 domain)
  747.      (cond ((eq 'tty (device-type device))
  748.         (face-equal-loop tty-props face1 face2 domain))
  749.            ((eq 'x (device-type device))
  750.         (face-equal-loop x-props face1 face2 domain))
  751.            (t t)))))
  752.  
  753. (defun face-differs-from-default-p (face &optional domain)
  754.   "True if the given face will display differently from the default face.
  755. See `face-property-instance' for the semantics of the DOMAIN argument."
  756.   (not (face-equal face 'default domain)))
  757.  
  758.  
  759. ;; This function is a terrible, disgusting hack!!!!  Need to
  760. ;; separate out the font elements as separate face properties!
  761.  
  762. ;; WE DEMAND LEXICAL SCOPING!!!
  763. ;; WE DEMAND LEXICAL SCOPING!!!
  764. ;; WE DEMAND LEXICAL SCOPING!!!
  765. ;; WE DEMAND LEXICAL SCOPING!!!
  766. ;; WE DEMAND LEXICAL SCOPING!!!
  767. ;; WE DEMAND LEXICAL SCOPING!!!
  768. ;; WE DEMAND LEXICAL SCOPING!!!
  769. ;; WE DEMAND LEXICAL SCOPING!!!
  770. ;; WE DEMAND LEXICAL SCOPING!!!
  771. ;; WE DEMAND LEXICAL SCOPING!!!
  772. ;; WE DEMAND LEXICAL SCOPING!!!
  773. ;; WE DEMAND LEXICAL SCOPING!!!
  774. ;; WE DEMAND LEXICAL SCOPING!!!
  775. ;; WE DEMAND LEXICAL SCOPING!!!
  776. ;; WE DEMAND LEXICAL SCOPING!!!
  777. (defun frob-face-property (face property func &optional locale)
  778.   "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE.
  779. This function is ugly and messy and is primarily used as an internal
  780. helper function for `make-face-bold' et al., so you probably don't
  781. want to use it or read the rest of the documentation.  But if you do ...
  782.  
  783. FUNC should be a function of two arguments (an instance and a device)
  784. that returns a modified name that is valid for the given device.
  785. If LOCALE specifies a valid domain (i.e. a window, frame, or device),
  786. this function instantiates the specifier over that domain, applies FUNC
  787. to the resulting instance, and adds the result back as an instantiator
  788. for that locale.  Otherwise, LOCALE should be a locale, locale type, or
  789. 'all (defaults to 'all if omitted).  For each specification thusly
  790. included: if the locale given is a valid domain, FUNC will be
  791. iterated over all valid instantiators for the device of the domain
  792. until a non-nil result is found (if there is no such result, the
  793. first valid instantiator is used), and that result substituted for
  794. the specification; otherwise, the process just outlined is
  795. iterated over each existing device and the concatenated results
  796. substituted for the specification."
  797.   (let ((sp (face-property face property)))
  798.     (if (valid-specifier-domain-p locale)
  799.     ;; this is easy.
  800.     (let* ((inst (face-property-instance face property locale))
  801.            (name (and inst (funcall func inst (dfw-device locale)))))
  802.       (when name
  803.         (add-spec-to-specifier sp name locale)))
  804.       ;; otherwise, map over all specifications ...
  805.       ;; but first, some further kludging:
  806.       ;; (1) if we're frobbing the global property, make sure
  807.       ;;     that something is there (copy from the default face,
  808.       ;;     if necessary).  Otherwise, something like
  809.       ;;     (make-face-larger 'modeline)
  810.       ;;     won't do anything at all if the modeline simply
  811.       ;;     inherits its font from 'default.
  812.       ;; (2) if we're frobbing a particular locale, nothing would
  813.       ;;     happen if that locale has no instantiators.  So signal
  814.       ;;     an error to indicate this.
  815.       (if (and (or (eq locale 'global) (eq locale 'all) (not locale))
  816.            (not (face-property face property 'global)))
  817.       (copy-specifier (face-property 'default property)
  818.               (face-property face property)
  819.               'global))
  820.       (if (and (valid-specifier-locale-p locale)
  821.            (not (face-property face property locale)))
  822.       (error "Property must have a specification in locale %S" locale))
  823.       (map-specifier
  824.        sp
  825.        (lambda (sp locale inst-list func)
  826.      (let* ((device (dfw-device locale))
  827.         ;; if a device can be derived from the locale,
  828.         ;; call frob-face-property-1 for that device.
  829.         ;; Otherwise map frob-face-property-1 over each device.
  830.         (result
  831.          (if device
  832.              (list (frob-face-property-1 sp device inst-list func))
  833.            (mapcar (lambda (device)
  834.                  (frob-face-property-1 sp device
  835.                            inst-list func))
  836.                (device-list))))
  837.         new-result)
  838.        ;; remove duplicates and nils from the obtained list of
  839.        ;; instantiators.
  840.        (mapcar (lambda (arg)
  841.              (when (and arg (not (member arg new-result)))
  842.                (setq new-result (cons arg new-result))))
  843.            result)
  844.        ;; add back in.
  845.        (add-spec-list-to-specifier sp (list (cons locale new-result)))
  846.        ;; tell map-specifier to keep going.
  847.        nil))
  848.        locale
  849.        func))))
  850.  
  851. (defun frob-face-property-1 (sp device inst-list func)
  852.   (let
  853.       (first-valid result)
  854.     (while (and inst-list (not result))
  855.       (let* ((inst-pair (car inst-list))
  856.          (tag-set (car inst-pair))
  857.          (sp-inst (specifier-instance-from-inst-list
  858.                sp device (list inst-pair))))
  859.     (if sp-inst
  860.         (progn
  861.           (if (not first-valid)
  862.           (setq first-valid inst-pair))
  863.           (setq result (funcall func sp-inst device))
  864.               (if result
  865.                   (setq result (cons tag-set result))))))
  866.       (setq inst-list (cdr inst-list)))
  867.     (or result first-valid)))
  868.  
  869. (defun frob-face-font-2 (face locale unfrobbed-face frobbed-face
  870.                   tty-thunk x-thunk standard-face-mapping)
  871.   ;; another kludge to make things more intuitive.  If we're
  872.   ;; inheriting from a standard face in this locale, frob the
  873.   ;; inheritance as appropriate.  Else, if, after the first X frobbing
  874.   ;; pass, the face hasn't changed and still looks like the standard
  875.   ;; unfrobbed face (e.g. 'default), make it inherit from the standard
  876.   ;; frobbed face (e.g. 'bold).  Regardless of things, do the TTY
  877.   ;; frobbing.
  878.  
  879.   ;; yuck -- The LOCALE argument to make-face-bold is not actually a locale,
  880.   ;; but is a "locale, locale-type, or nil for all".  So ...  do our extra
  881.   ;; frobbing only if it's actually a locale; or for nil, do the frobbing
  882.   ;; on 'global.  This specifier stuff needs some rethinking.
  883.   (let* ((the-locale (cond ((null locale) 'global)
  884.                ((valid-specifier-locale-p locale) locale)
  885.                (t nil)))
  886.      (specs (and the-locale (face-font face the-locale nil t)))
  887.      (change-it (and specs (cdr (assoc specs standard-face-mapping)))))
  888.     (if (and change-it
  889.          (not (memq (face-name (find-face face))
  890.             '(default bold italic bold-italic))))
  891.     (progn
  892.       (or (equal change-it t)
  893.           (set-face-property face 'font change-it the-locale))
  894.       (funcall tty-thunk))
  895.       (let* ((domain (cond ((null the-locale) nil)
  896.                ((valid-specifier-domain-p the-locale) the-locale)
  897.                ;; OK, this next one is truly a kludge, but
  898.                ;; it results in more intuitive behavior most
  899.                ;; of the time. (really!)
  900.                ((or (eq the-locale 'global) (eq the-locale 'all))
  901.                 (selected-device))
  902.                (t nil)))
  903.          (inst (and domain (face-property-instance face 'font domain))))
  904.     (funcall tty-thunk)
  905.     (funcall x-thunk)
  906.     ;; If it's reasonable to do the inherit-from-standard-face trick,
  907.     ;; and it's called for, then do it now.
  908.     (or (null domain)
  909.         (not (equal inst (face-property-instance face 'font domain)))
  910.         ;; don't do it for standard faces, or you'll get inheritance loops.
  911.         ;; #### This makes XEmacs seg fault! fix this bug.
  912.         (memq (face-name (find-face face))
  913.           '(default bold italic bold-italic))
  914.         (not (equal (face-property-instance face 'font domain)
  915.             (face-property-instance unfrobbed-face 'font domain)))
  916.         (set-face-property face 'font (vector frobbed-face)
  917.                    the-locale))))))
  918.  
  919. (defun make-face-bold (face &optional locale)
  920.   "Make the face bold, if possible.
  921. This will attempt to make the font bold for X locales and will set the
  922. highlight flag for TTY locales.
  923.  
  924. If LOCALE is nil, omitted, or `all', this will attempt to frob all
  925. font specifications for FACE to make them appear bold.  Similarly, if
  926. LOCALE is a locale type, this frobs all font specifications for locales
  927. of that type.  If LOCALE is a particular locale, what happens depends on
  928. what sort of locale is given.  If you gave a device, frame, or window,
  929. then it's always possible to determine what the font actually will be,
  930. so this is determined and the resulting font is frobbed and added back as a
  931. specification for this locale.  If LOCALE is a buffer, however, you can't
  932. determine what the font will actually be unless there's actually a
  933. specification given for that particular buffer (otherwise, it depends
  934. on what window and frame the buffer appears in, and might not even be
  935. well-defined if the buffer appears multiple times in different places);
  936. therefore you will get an error unless there's a specification for the
  937. buffer.
  938.  
  939. Finally, in some cases (specifically, when LOCALE is not a locale type),
  940. if the frobbing didn't actually make the font look any different
  941. \(this happens, for example, if your font specification is already bold
  942. or has no bold equivalent), and currently looks like the font of the
  943. 'default face, it is set to inherit from the 'bold face.  This is kludgy
  944. but it makes `make-face-bold' have more intuitive behavior in many
  945. circumstances."
  946.   (interactive (list (read-face-name "Make which face bold: ")))
  947.   (frob-face-font-2
  948.    face locale 'default 'bold
  949.    (lambda ()
  950.      ;; handle TTY specific entries
  951.      (when (featurep 'tty)
  952.        (set-face-highlight-p face t locale 'tty)))
  953.    (lambda ()
  954.      ;; handle X specific entries
  955.      (frob-face-property face 'font 'x-make-font-bold locale))
  956.    '(([default] . [bold])
  957.      ([bold] . t)
  958.      ([italic] . [bold-italic])
  959.      ([bold-italic] . t))))
  960.  
  961. (defun make-face-italic (face &optional locale)
  962.   "Make the face italic, if possible.
  963. This will attempt to make the font italic for X locales and will set
  964. the underline flag for TTY locales.
  965. See `make-face-bold' for the semantics of the LOCALE argument and
  966. for more specifics on exactly how this function works."
  967.   (interactive (list (read-face-name "Make which face italic: ")))
  968.   (frob-face-font-2
  969.    face locale 'default 'italic
  970.    (lambda ()
  971.      ;; handle TTY specific entries
  972.      (when (featurep 'tty)
  973.        (set-face-underline-p face t locale 'tty)))
  974.    (lambda ()
  975.      ;; handle X specific entries
  976.      (frob-face-property face 'font 'x-make-font-italic locale))
  977.    '(([default] . [italic])
  978.      ([bold] . [bold-italic])
  979.      ([italic] . t)
  980.      ([bold-italic] . t))))
  981.  
  982. (defun make-face-bold-italic (face &optional locale)
  983.   "Make the face bold and italic, if possible.
  984. This will attempt to make the font bold-italic for X locales and will
  985. set the highlight and underline flags for TTY locales.
  986. See `make-face-bold' for the semantics of the LOCALE argument and
  987. for more specifics on exactly how this function works."
  988.   (interactive (list (read-face-name "Make which face bold-italic: ")))
  989.   (frob-face-font-2
  990.    face locale 'default 'bold-italic
  991.    (lambda ()
  992.      ;; handle TTY specific entries
  993.      (when (featurep 'tty)
  994.        (set-face-highlight-p face t locale 'tty)
  995.        (set-face-underline-p face t locale 'tty)))
  996.    (lambda ()
  997.      ;; handle X specific entries
  998.      (frob-face-property face 'font 'x-make-font-bold-italic locale))
  999.    '(([default] . [italic])
  1000.      ([bold] . [bold-italic])
  1001.      ([italic] . [bold-italic])
  1002.      ([bold-italic] . t))))
  1003.  
  1004. (defun make-face-unbold (face &optional locale)
  1005.   "Make the face non-bold, if possible.
  1006. This will attempt to make the font non-bold for X locales and will
  1007. unset the highlight flag for TTY locales.
  1008. See `make-face-bold' for the semantics of the LOCALE argument and
  1009. for more specifics on exactly how this function works."
  1010.   (interactive (list (read-face-name "Make which face non-bold: ")))
  1011.   (frob-face-font-2
  1012.    face locale 'bold 'default
  1013.    (lambda ()
  1014.      ;; handle TTY specific entries
  1015.      (when (featurep 'tty)
  1016.        (set-face-highlight-p face nil locale 'tty)))
  1017.    (lambda ()
  1018.      ;; handle X specific entries
  1019.      (frob-face-property face 'font 'x-make-font-unbold locale))
  1020.    '(([default] . t)
  1021.      ([bold] . [default])
  1022.      ([italic] . t)
  1023.      ([bold-italic] . [italic]))))
  1024.  
  1025. (defun make-face-unitalic (face &optional locale)
  1026.   "Make the face non-italic, if possible.
  1027. This will attempt to make the font non-italic for X locales and will
  1028. unset the underline flag for TTY locales.
  1029. See `make-face-bold' for the semantics of the LOCALE argument and
  1030. for more specifics on exactly how this function works."
  1031.   (interactive (list (read-face-name "Make which face non-italic: ")))
  1032.   (frob-face-font-2
  1033.    face locale 'italic 'default
  1034.    (lambda ()
  1035.      ;; handle TTY specific entries
  1036.      (when (featurep 'tty)
  1037.        (set-face-underline-p face nil locale 'tty)))
  1038.    (lambda ()
  1039.      ;; handle X specific entries
  1040.      (frob-face-property face 'font 'x-make-font-unitalic locale))
  1041.    '(([default] . t)
  1042.      ([bold] . t)
  1043.      ([italic] . [default])
  1044.      ([bold-italic] . [bold]))))
  1045.  
  1046.  
  1047. ;; Why do the following two functions lose so badly in so many
  1048. ;; circumstances?
  1049.  
  1050. (defun make-face-smaller (face &optional locale)
  1051.   "Make the font of the given face be smaller, if possible.
  1052. LOCALE works as in `make-face-bold' et al., but the ``inheriting-
  1053. from-the-bold-face'' operations described there are not done
  1054. because they don't make sense in this context."
  1055.   (interactive (list (read-face-name "Shrink which face: ")))
  1056.   ;; handle X specific entries
  1057.   (frob-face-property face 'font 'x-find-smaller-font locale))
  1058.  
  1059. (defun make-face-larger (face &optional locale)
  1060.   "Make the font of the given face be larger, if possible.
  1061. See `make-face-smaller' for the semantics of the LOCALE argument."
  1062.   (interactive (list (read-face-name "Enlarge which face: ")))
  1063.   ;; handle X specific entries
  1064.   (frob-face-property face 'font 'x-find-larger-font locale))
  1065.  
  1066. (defun invert-face (face &optional locale)
  1067.   "Swap the foreground and background colors of the face."
  1068.   (interactive (list (read-face-name "Invert face: ")))
  1069.   (if (valid-specifier-domain-p locale)
  1070.       (let ((foreface (face-foreground-instance face locale)))
  1071.     (set-face-foreground face (face-background-instance face locale)
  1072.                  locale)
  1073.     (set-face-background face foreface locale))
  1074.     (let ((forespec (copy-specifier (face-foreground face) nil locale)))
  1075.       (copy-specifier (face-background face) (face-foreground face) locale)
  1076.       (copy-specifier forespec (face-background face) locale))))
  1077.  
  1078.  
  1079. ;;; Convenience functions
  1080.  
  1081. (defun face-ascent (face &optional domain charset)
  1082.   "Return the ascent of a face.
  1083. See `face-property-instance' for the semantics of the DOMAIN argument."
  1084.   (font-ascent (face-font face) domain charset))
  1085.  
  1086. (defun face-descent (face &optional domain charset)
  1087.   "Return the descent of a face.
  1088. See `face-property-instance' for the semantics of the DOMAIN argument."
  1089.   (font-descent (face-font face) domain charset))
  1090.  
  1091. (defun face-width (face &optional domain charset)
  1092.   "Return the width of a face.
  1093. See `face-property-instance' for the semantics of the DOMAIN argument."
  1094.   (font-width (face-font face) domain charset))
  1095.  
  1096. (defun face-height (face &optional domain charset)
  1097.   "Return the height of a face.
  1098. See `face-property-instance' for the semantics of the DOMAIN argument."
  1099.   (+ (face-ascent face domain charset) (face-descent face domain charset)))
  1100.  
  1101. (defun face-proportional-p (face &optional domain charset)
  1102.   "Return whether FACE is proportional.
  1103. See `face-property-instance' for the semantics of the DOMAIN argument."
  1104.   (font-proportional-p (face-font face) domain charset))
  1105.  
  1106.  
  1107. ;; Functions that used to be in cus-face.el, but logically go here.
  1108.  
  1109. (defcustom frame-background-mode nil
  1110.   "*The brightness of the background.
  1111. Set this to the symbol dark if your background color is dark, light if
  1112. your background is light, or nil (default) if you want Emacs to
  1113. examine the brightness for you."
  1114.   :group 'faces
  1115.   :type '(choice (choice-item dark) 
  1116.          (choice-item light)
  1117.          (choice-item :tag "Auto" nil)))
  1118.  
  1119. ;; The old variable that many people still have in .emacs files.
  1120. (define-obsolete-variable-alias 'custom-background-mode
  1121.   'frame-background-mode)
  1122.  
  1123. (defun get-frame-background-mode (frame)
  1124.   "Detect background mode for FRAME."
  1125.   (let* ((color-instance (face-background-instance 'default frame))
  1126.      (mode (condition-case nil
  1127.            (if (< (apply '+ (color-instance-rgb-components
  1128.                      color-instance)) 65536)
  1129.                'dark 'light)
  1130.          ;; Here, we get an error on a TTY.  As we don't have
  1131.          ;; a good way of detecting whether a TTY is light or
  1132.          ;; dark, we'll guess it's dark.
  1133.          (error 'dark))))
  1134.     (set-frame-property frame 'background-mode mode)
  1135.     mode))
  1136.  
  1137. (defun extract-custom-frame-properties (frame)
  1138.   "Return a plist with the frame properties of FRAME used by custom."
  1139.   (list 'type (or (frame-property frame 'display-type)
  1140.           (device-type (frame-device frame)))
  1141.     'class (device-class (frame-device frame))
  1142.     'background (or frame-background-mode
  1143.             (frame-property frame 'background-mode)
  1144.             (get-frame-background-mode frame))))
  1145.  
  1146. (defcustom init-face-from-resources t
  1147.   "If non nil, attempt to initialize faces from the resource database."
  1148.   :group 'faces
  1149.   :type 'boolean)
  1150.  
  1151. ;; Old name, used by custom.  Also, FSFmacs name.
  1152. (defvaralias 'initialize-face-resources 'init-face-from-resources)
  1153.  
  1154. (defun face-spec-set (face spec &optional frame)
  1155.   "Set FACE's face attributes according to the first matching entry in SPEC.
  1156. If optional FRAME is non-nil, set it for that frame only.
  1157. If it is nil, then apply SPEC to each frame individually.
  1158. See `defface' for information about SPEC."
  1159.   (if frame
  1160.       (progn
  1161.     (reset-face face frame)
  1162.     (face-display-set face spec frame)
  1163.     (init-face-from-resources face frame))
  1164.     (let ((frames (relevant-custom-frames)))
  1165.       (reset-face face)
  1166.       (face-display-set face spec)
  1167.       (while frames
  1168.     (face-display-set face spec (car frames))
  1169.     (pop frames))
  1170.       (init-face-from-resources face))))
  1171.  
  1172. (defun face-display-set (face spec &optional frame)
  1173.   "Set FACE to the attributes to the first matching entry in SPEC.
  1174. Iff optional FRAME is non-nil, set it for that frame only.
  1175. See `defface' for information about SPEC."
  1176.   (while spec
  1177.     (let ((display (caar spec))
  1178.       (atts (cadar spec)))
  1179.       (pop spec)
  1180.       (when (face-spec-set-match-display display frame)
  1181.     ;; Avoid creating frame local duplicates of the global face.
  1182.     (unless (and frame (eq display (get face 'custom-face-display)))
  1183.       (apply 'face-custom-attributes-set face frame atts))
  1184.     (unless frame
  1185.       (put face 'custom-face-display display))
  1186.     (setq spec nil)))))
  1187.  
  1188. (defvar default-custom-frame-properties nil
  1189.   "The frame properties used for the global faces.
  1190. Frames not matching these propertiess should have frame local faces.
  1191. The value should be nil, if uninitialized, or a plist otherwise.  
  1192. See `defface' for a list of valid keys and values for the plist.")
  1193.  
  1194. (defun get-custom-frame-properties (&optional frame)
  1195.   "Return a plist with the frame properties of FRAME used by custom.
  1196. If FRAME is nil, return the default frame properties."
  1197.   (cond (frame
  1198.      ;; Try to get from cache.
  1199.      (let ((cache (frame-property frame 'custom-properties)))
  1200.        (unless cache
  1201.          ;; Oh well, get it then.
  1202.          (setq cache (extract-custom-frame-properties frame))
  1203.          ;; and cache it...
  1204.          (set-frame-property frame 'custom-properties cache))
  1205.        cache))
  1206.     (default-custom-frame-properties)
  1207.     (t
  1208.      (setq default-custom-frame-properties
  1209.            (extract-custom-frame-properties (selected-frame))))))
  1210.  
  1211. (defun face-spec-set-match-display (display frame)
  1212.   "Non-nil iff DISPLAY matches FRAME.
  1213. DISPLAY is part of a spec such as can be used in `defface'.
  1214. If FRAME is nil, the current FRAME is used."
  1215.   (if (eq display t)
  1216.       t
  1217.     (let* ((props (get-custom-frame-properties frame))
  1218.        (type (plist-get props 'type))
  1219.        (class (plist-get props 'class))
  1220.        (background (plist-get props 'background))
  1221.        (match t)
  1222.        (entries display)
  1223.        entry req options)
  1224.       (while (and entries match)
  1225.     (setq entry (car entries)
  1226.           entries (cdr entries)
  1227.           req (car entry)
  1228.           options (cdr entry)
  1229.           match (case req
  1230.               (type       (memq type options))
  1231.               (class      (memq class options))
  1232.               (background (memq background options))
  1233.               (t (warn "Unknown req `%S' with options `%S'"
  1234.                    req options)
  1235.              nil))))
  1236.       match)))
  1237.  
  1238. (defun relevant-custom-frames ()
  1239.   "List of frames whose custom properties differ from the default."
  1240.   (let ((relevant nil)
  1241.     (default (get-custom-frame-properties))
  1242.     (frames (frame-list))
  1243.     frame)
  1244.     (while frames
  1245.       (setq frame (car frames)
  1246.         frames (cdr frames))
  1247.       (unless (equal default (get-custom-frame-properties frame))
  1248.     (push frame relevant)))
  1249.     relevant))
  1250.  
  1251. (defun initialize-custom-faces (&optional frame)
  1252.   "Initialize all custom faces for FRAME.
  1253. If FRAME is nil or omitted, initialize them for all frames."
  1254.   (mapc (lambda (symbol)
  1255.       (let ((spec (or (get symbol 'saved-face)
  1256.               (get symbol 'face-defface-spec))))
  1257.         (when spec
  1258.           ;; No need to init-face-from-resources -- code in
  1259.           ;; `init-frame-faces' does it already.
  1260.           (face-display-set symbol spec frame))))
  1261.     (face-list)))
  1262.  
  1263. (defun custom-initialize-frame (frame)
  1264.   "Initialize frame-local custom faces for FRAME if necessary."
  1265.   (unless (equal (get-custom-frame-properties) 
  1266.          (get-custom-frame-properties frame))
  1267.     (initialize-custom-faces frame)))
  1268.  
  1269.  
  1270. (defun make-empty-face (name &optional doc-string temporary)
  1271.   "Like `make-face', but doesn't query the resource database."
  1272.   (let ((init-face-from-resources nil))
  1273.     (make-face name doc-string temporary)))
  1274.  
  1275. (defun init-face-from-resources (face &optional locale)
  1276.   "Initialize FACE from the resource database.
  1277. If LOCALE is specified, it should be a frame, device, or 'global, and
  1278. the face will be resourced over that locale.  Otherwise, the face will
  1279. be resourced over all possible locales (i.e. all frames, all devices,
  1280. and 'global)."
  1281.   (cond ((null init-face-from-resources)
  1282.      ;; Do nothing.
  1283.      )
  1284.     ((not locale)
  1285.      ;; Global, set for all frames.
  1286.      (progn
  1287.        (init-face-from-resources face 'global)
  1288.        (let ((devices (device-list)))
  1289.          (while devices
  1290.            (init-face-from-resources face (car devices))
  1291.            (setq devices (cdr devices))))
  1292.        (let ((frames (frame-list)))
  1293.          (while frames
  1294.            (init-face-from-resources face (car frames))
  1295.            (setq frames (cdr frames))))))
  1296.     (t
  1297.      ;; Specific.
  1298.      (let ((devtype (cond ((devicep locale) (device-type locale))
  1299.                   ((framep locale) (frame-type locale))
  1300.                   (t nil))))
  1301.        (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype))
  1302.           (x-init-face-from-resources face locale))
  1303.          ((or (not devtype) (eq 'tty devtype))
  1304.           ;; Nothing to do for TTYs?
  1305.           ))))))
  1306.  
  1307. (defun init-device-faces (device)
  1308.   ;; First, add any device-local face resources.
  1309.   (when init-face-from-resources
  1310.     (loop for face in (face-list) do
  1311.       (init-face-from-resources face device))
  1312.     ;; Then do any device-specific initialization.
  1313.     (cond ((eq 'x (device-type device))
  1314.        (x-init-device-faces device))
  1315.       ;; Nothing to do for TTYs?
  1316.       )
  1317.     (init-other-random-faces device)))
  1318.  
  1319. (defun init-frame-faces (frame)
  1320.   (when init-face-from-resources
  1321.     ;; First, add any frame-local face resources.
  1322.     (loop for face in (face-list) do
  1323.       (init-face-from-resources face frame))
  1324.     ;; Then do any frame-specific initialization.
  1325.     (cond ((eq 'x (frame-type frame))
  1326.        (x-init-frame-faces frame))
  1327.       ;; Is there anything which should be done for TTY's?
  1328.       )))
  1329.  
  1330. ;; #### This is somewhat X-specific, and is called when the first
  1331. ;; X device is created (even if there were TTY devices created
  1332. ;; beforehand).  The concept of resources has not been generalized
  1333. ;; outside of X-specificness, so we have to live with this
  1334. ;; breach of device-independence.
  1335.  
  1336. (defun init-global-faces ()
  1337.   ;; Look for global face resources.
  1338.   (loop for face in (face-list) do
  1339.     (init-face-from-resources face 'global))
  1340.   ;; Further X frobbing.
  1341.   (x-init-global-faces)
  1342.   ;; for bold and the like, make the global specification be bold etc.
  1343.   ;; if the user didn't already specify a value.  These will also be
  1344.   ;; frobbed further in init-other-random-faces.
  1345.   (unless (face-font 'bold 'global)
  1346.     (make-face-bold 'bold 'global))
  1347.   ;;
  1348.   (unless (face-font 'italic 'global)
  1349.     (make-face-italic 'italic 'global))
  1350.   ;;
  1351.   (unless (face-font 'bold-italic 'global)
  1352.     (make-face-bold-italic 'bold-italic 'global)
  1353.     (unless (face-font 'bold-italic 'global)
  1354.       (copy-face 'bold 'bold-italic)
  1355.       (make-face-italic 'bold-italic)))
  1356.  
  1357.   (when (face-equal 'bold 'bold-italic)
  1358.     (copy-face 'italic 'bold-italic)
  1359.     (make-face-bold 'bold-italic))
  1360.   ;;
  1361.   ;; Nothing more to be done for X or TTY's?
  1362.   )
  1363.  
  1364.  
  1365. ;; These warnings are there for a reason.  Just specify your fonts
  1366. ;; correctly.  Deal with it.  Additionally, one can use
  1367. ;; `log-warning-minimum-level' instead of this.
  1368. ;(defvar inhibit-font-complaints nil
  1369. ;  "Whether to suppress complaints about incomplete sets of fonts.")
  1370.  
  1371. (defun face-complain-about-font (face device)
  1372.   (if (symbolp face) (setq face (symbol-name face)))
  1373. ;;  (if (not inhibit-font-complaints)
  1374.   (display-warning
  1375.    'font
  1376.    (let ((default-name (face-font-name 'default device)))
  1377.      (format "%s: couldn't deduce %s %s version of the font
  1378. %S.
  1379.  
  1380. Please specify X resources to make the %s face
  1381. visually distinguishable from the default face.
  1382. For example, you could add one of the following to $HOME/Emacs:
  1383.  
  1384. Emacs.%s.attributeFont: -dt-*-medium-i-*
  1385. or
  1386. Emacs.%s.attributeForeground: hotpink\n"
  1387.              invocation-name
  1388.              (if (string-match "\\`[aeiouAEIOU]" face) "an" "a")
  1389.              face
  1390.              default-name
  1391.              face
  1392.              face
  1393.              face
  1394.              ))))
  1395.  
  1396.  
  1397. ;; #### This is quite a mess.  We should use the custom mechanism for
  1398. ;; most of this stuff.  Currently we don't do it, because Custom
  1399. ;; doesn't use specifiers (yet.)  FSF does it the Right Way.
  1400.  
  1401. ;; For instance, the definition of `bold' should be something like
  1402. ;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should
  1403. ;; make sure that everything works properly.
  1404.  
  1405. (defun init-other-random-faces (device)
  1406.   "Initializes the colors and fonts of the bold, italic, bold-italic,
  1407. zmacs-region, list-mode-item-selected, highlight, primary-selection,
  1408. secondary-selection, and isearch faces when each device is created.  If
  1409. you want to add code to do stuff like this, use the create-device-hook."
  1410.  
  1411.   ;; try to make 'bold look different from the default on this device.
  1412.   ;; If that doesn't work at all, then issue a warning.
  1413.   (unless (face-differs-from-default-p 'bold device)
  1414.     (make-face-bold 'bold device)
  1415.     (unless (face-differs-from-default-p 'bold device)
  1416.       (make-face-unbold 'bold device)
  1417.       (unless (face-differs-from-default-p 'bold device)
  1418.     ;; the luser specified one of the bogus font names
  1419.     (face-complain-about-font 'bold device))))
  1420.  
  1421.   ;; Similar for italic.
  1422.   ;; It's unreasonable to expect to be able to make a font italic all
  1423.   ;; the time.  For many languages, italic is an alien concept.
  1424.   ;; Basically, because italic is not a globally meaningful concept,
  1425.   ;; the use of the italic face should really be oboleted.
  1426.   
  1427.   ;; I disagree with above.  In many languages, the concept of capital
  1428.   ;; letters is just as alien, and yet we use them.  Italic is here to
  1429.   ;; stay.  -hniksic
  1430.  
  1431.   ;; In a Solaris Japanese environment, there just aren't any italic
  1432.   ;; fonts - period.  CDE recognizes this reality, and fonts
  1433.   ;; -dt-interface user-medium-r-normal-*-*-*-*-*-*-*-*-* don't come
  1434.   ;; in italic versions.  So we first try to make the font bold before
  1435.   ;; complaining.
  1436.   (unless (face-differs-from-default-p 'italic device)
  1437.     (make-face-italic 'italic device)
  1438.     (unless (face-differs-from-default-p 'italic device)
  1439.       (make-face-bold 'italic device)
  1440.       (unless (face-differs-from-default-p 'italic device)
  1441.     (face-complain-about-font 'italic device))))
  1442.  
  1443.   ;; similar for bold-italic.
  1444.   (unless (face-differs-from-default-p 'bold-italic device)
  1445.     (make-face-bold-italic 'bold-italic device)
  1446.     ;; if we couldn't get a bold-italic version, try just bold.
  1447.     (unless (face-differs-from-default-p 'bold-italic device)
  1448.       (make-face-bold 'bold-italic device)
  1449.       ;; if we couldn't get bold or bold-italic, then that's probably because
  1450.       ;; the default font is bold, so make the `bold-italic' face be unbold.
  1451.       (unless (face-differs-from-default-p 'bold-italic device)
  1452.     (make-face-unbold 'bold-italic device)
  1453.     (make-face-italic 'bold-italic device)
  1454.     (unless (face-differs-from-default-p 'bold-italic device)
  1455.       ;; if that didn't work, try plain italic
  1456.       ;; (can this ever happen? what the hell.)
  1457.       (make-face-italic 'bold-italic device)
  1458.       (unless (face-differs-from-default-p 'bold-italic device)
  1459.         ;; then bitch and moan.
  1460.         (face-complain-about-font 'bold-italic device))))))
  1461.  
  1462.   ;; Set the text-cursor colors unless already specified.
  1463.   (when (and (not (eq 'tty (device-type device)))
  1464.          (not (face-background 'text-cursor 'global))
  1465.          (face-property-equal 'text-cursor 'default 'background device))
  1466.     (set-face-background 'text-cursor [default foreground] 'global
  1467.              nil 'append))
  1468.   (when (and (not (eq 'tty (device-type device)))
  1469.          (not (face-foreground 'text-cursor 'global))
  1470.          (face-property-equal 'text-cursor 'default 'foreground device))
  1471.     (set-face-foreground 'text-cursor [default background] 'global
  1472.              nil 'append))
  1473.  
  1474.   ;; Set the secondary-selection color unless already specified.
  1475.   (unless (or (face-differs-from-default-p 'highlight device)
  1476.           (face-background 'highlight 'global))
  1477.     ;; some older servers don't recognize "darkseagreen2"
  1478.     (set-face-background 'highlight
  1479.              '((color . "darkseagreen2")
  1480.                (color . "green"))
  1481.              'global nil 'append)
  1482.     (set-face-background 'highlight "gray53" 'global 'grayscale 'append))
  1483.   (unless (or (face-differs-from-default-p 'highlight device)
  1484.           (face-background-pixmap 'highlight 'global))
  1485.     (set-face-background-pixmap 'highlight [nothing] 'global 'color 'append)
  1486.     (set-face-background-pixmap 'highlight [nothing] 'global 'grayscale 'append)
  1487.     (set-face-background-pixmap 'highlight "gray1" 'global 'mono 'append))
  1488.   ;; if the highlight face isn't distinguished on this device,
  1489.   ;; at least try inverting it.
  1490.   (unless (face-differs-from-default-p 'highlight device)
  1491.     (invert-face 'highlight device))
  1492.  
  1493.   ;; first time through, set the zmacs-region color if it's not already
  1494.   ;; specified.
  1495.   (unless (or (face-differs-from-default-p 'zmacs-region device)
  1496.           (face-background 'zmacs-region 'global))
  1497.     (set-face-background 'zmacs-region "gray65" 'global 'color)
  1498.     (set-face-background 'zmacs-region "gray65" 'global 'grayscale))
  1499.   (unless (or (face-differs-from-default-p 'zmacs-region device)
  1500.           (face-background-pixmap 'zmacs-region 'global))
  1501.     (set-face-background-pixmap 'zmacs-region [nothing] 'global 'color)
  1502.     (set-face-background-pixmap 'zmacs-region [nothing] 'global 'grayscale)
  1503.     (set-face-background-pixmap 'zmacs-region "gray3" 'global 'mono))
  1504.   ;; if the zmacs-region face isn't distinguished on this device,
  1505.   ;; at least try inverting it.
  1506.   (unless (face-differs-from-default-p 'zmacs-region device)
  1507.     (invert-face 'zmacs-region device))
  1508.  
  1509.   ;; first time through, set the list-mode-item-selected color if it's
  1510.   ;; not already specified.
  1511.   (unless (or (face-differs-from-default-p 'list-mode-item-selected device)
  1512.           (face-background 'list-mode-item-selected 'global))
  1513.     (set-face-background 'list-mode-item-selected "gray68" 'global 'color)
  1514.     (set-face-background 'list-mode-item-selected "gray68" 'global 'grayscale)
  1515.     (unless (face-foreground 'list-mode-item-selected 'global)
  1516.       (set-face-background 'list-mode-item-selected
  1517.                [default foreground] 'global '(mono x))
  1518.       (set-face-foreground 'list-mode-item-selected
  1519.                [default background] 'global '(mono x))))
  1520.   ;; if the list-mode-item-selected face isn't distinguished on this device,
  1521.   ;; at least try inverting it.
  1522.   (unless (face-differs-from-default-p 'list-mode-item-selected device)
  1523.     (invert-face 'list-mode-item-selected device))
  1524.  
  1525.   ;; Set the primary-selection color unless already specified.
  1526.   (unless (or (face-differs-from-default-p 'primary-selection device)
  1527.           (face-background 'primary-selection 'global))
  1528.     (set-face-background 'primary-selection "gray65" 'global 'color)
  1529.     (set-face-background 'primary-selection "gray65" 'global 'grayscale))
  1530.   (unless (or (face-differs-from-default-p 'secondary-selection device)
  1531.           (face-background-pixmap 'primary-selection 'global))
  1532.     (set-face-background-pixmap 'primary-selection "gray3" 'global 'mono))
  1533.   ;; If the primary-selection face isn't distinguished on this device,
  1534.   ;; at least try inverting it.
  1535.   (unless (face-differs-from-default-p 'primary-selection device)
  1536.     (invert-face 'primary-selection device))
  1537.  
  1538.   ;; Set the secondary-selection color unless already specified.
  1539.   (unless (or (face-differs-from-default-p 'secondary-selection device)
  1540.           (face-background 'secondary-selection 'global))
  1541.     (set-face-background 'secondary-selection
  1542.              '((color . "paleturquoise")
  1543.                (color . "green"))
  1544.              'global)
  1545.     (set-face-background 'secondary-selection "gray53" 'global
  1546.              'grayscale))
  1547.   (unless (or (face-differs-from-default-p 'secondary-selection device)
  1548.           (face-background-pixmap 'secondary-selection 'global))
  1549.     (set-face-background-pixmap 'secondary-selection "gray1" 'global 'mono))
  1550.   ;; If the secondary-selection face isn't distinguished on this device,
  1551.   ;; at least try inverting it.
  1552.   (unless (face-differs-from-default-p 'secondary-selection device)
  1553.     (invert-face 'secondary-selection device))
  1554.  
  1555.   ;; Set the isearch color if unless already specified.
  1556.   (unless (or (face-differs-from-default-p 'isearch device)
  1557.           (face-background 'isearch 'global))
  1558.     ;; TTY's and some older X servers don't recognize "paleturquoise"
  1559.     (set-face-background 'isearch
  1560.              '((color . "paleturquoise")
  1561.                (color . "green"))
  1562.              'global))
  1563.   ;; if the isearch face isn't distinguished (e.g. we're not on a color
  1564.   ;; display), at least try making it bold.
  1565.   (unless (face-differs-from-default-p 'isearch device)
  1566.     (set-face-font 'isearch [bold]))
  1567.   )
  1568.  
  1569. ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle Jones.
  1570. (defun set-face-stipple (face pixmap &optional frame)
  1571.   "Change the stipple pixmap of face FACE to PIXMAP.
  1572. This is an Emacs compatibility function; consider using
  1573. set-face-background-pixmap instead.
  1574.  
  1575. PIXMAP should be a string, the name of a file of pixmap data.
  1576. The directories listed in the `x-bitmap-file-path' variable are searched.
  1577.  
  1578. Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT
  1579. DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is
  1580. a string, containing the raw bits of the bitmap.  XBM data is
  1581. expected in this case, other types of image data will not work.
  1582.  
  1583. If the optional FRAME argument is provided, change only
  1584. in that frame; otherwise change each frame."
  1585.   (while (not (find-face face))
  1586.     (setq face (signal 'wrong-type-argument (list 'facep face))))
  1587.   (locate-file pixmap x-bitmap-file-path ".xbm:" 4)
  1588.   (while (cond ((stringp pixmap)
  1589.         (unless (file-readable-p pixmap)
  1590.           (setq pixmap `[xbm :file ,pixmap]))
  1591.         nil)
  1592.            ((and (consp pixmap) (= (length pixmap) 3))
  1593.         (setq pixmap `[xbm :data ,pixmap])
  1594.         nil)
  1595.            (t t))
  1596.     (setq pixmap (signal 'wrong-type-argument
  1597.              (list 'stipple-pixmap-p pixmap))))
  1598.   (while (and frame (not (framep frame)))
  1599.     (setq frame (signal 'wrong-type-argument (list 'framep frame))))
  1600.   (set-face-background-pixmap face pixmap frame))
  1601.  
  1602.  
  1603. ;; Create the remaining standard faces now.  This way, packages that we dump
  1604. ;; can reference these faces as parents.
  1605. ;;
  1606. ;; The default, modeline, left-margin, right-margin, text-cursor,
  1607. ;; and pointer faces are created in C.
  1608.  
  1609. (make-face 'bold "Bold text.")
  1610. (make-face 'italic "Italic text.")
  1611. (make-face 'bold-italic "Bold-italic text.")
  1612. (make-face 'underline "Underlined text.")
  1613. (or (face-differs-from-default-p 'underline)
  1614.     (set-face-underline-p 'underline t 'global))
  1615. (make-face 'zmacs-region "Used on highlightes region between point and mark.")
  1616. (make-face 'isearch "Used on region matched by isearch.")
  1617. (make-face 'list-mode-item-selected
  1618.        "Face for the selected list item in list-mode.")
  1619. (make-face 'highlight "Highlight face.")
  1620. (make-face 'primary-selection "Primary selection face.")
  1621. (make-face 'secondary-selection "Secondary selection face.")
  1622.  
  1623. ;; Several useful color faces.
  1624. (dolist (color '(red green blue yellow))
  1625.   (make-face color (concat (symbol-name color) " text."))
  1626.   (set-face-foreground color (symbol-name color) nil 'color))
  1627.  
  1628. ;; Make some useful faces.  This happens very early, before creating
  1629. ;; the first non-stream device.  We initialize the tty global values here.
  1630. ;; We cannot initialize the X global values here because they depend
  1631. ;; on having already resourced the global face specs, which happens
  1632. ;; when the first X device is created.
  1633.  
  1634. (when (featurep 'tty)
  1635.   (set-face-highlight-p 'bold                    t 'global 'tty)
  1636.   (set-face-underline-p 'italic                  t 'global 'tty)
  1637.   (set-face-highlight-p 'bold-italic             t 'global 'tty)
  1638.   (set-face-underline-p 'bold-italic             t 'global 'tty)
  1639.   (set-face-highlight-p 'highlight               t 'global 'tty)
  1640.   (set-face-reverse-p   'text-cursor             t 'global 'tty)
  1641.   (set-face-reverse-p   'modeline                t 'global 'tty)
  1642.   (set-face-reverse-p   'zmacs-region            t 'global 'tty)
  1643.   (set-face-reverse-p   'primary-selection       t 'global 'tty)
  1644.   (set-face-underline-p 'secondary-selection     t 'global 'tty)
  1645.   (set-face-reverse-p   'list-mode-item-selected t 'global 'tty)
  1646.   (set-face-reverse-p   'isearch                 t 'global 'tty)
  1647.   )
  1648.  
  1649. ;;; faces.el ends here
  1650.